home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / TABLES / MTABLE / BTNBAR.PAS next >
Pascal/Delphi Source File  |  1994-03-25  |  24KB  |  966 lines
  1. unit BtnBar;
  2.  
  3. interface
  4.  
  5. uses
  6.   Winprocs,
  7.   Wintypes,
  8.   Objects,
  9.   OWindows,
  10.   Strings,
  11.   Win31,
  12.   MLBTypes;
  13.  
  14. {$R BTNBAR.RES}
  15.  
  16. const
  17.   tm_CalcParentClientRect  = wm_User + 120;
  18.   tm_SizingEnd             = wm_User + 122;
  19.   tm_NewColSize            = wm_User + 127;
  20.   tm_FirstColSize          = wm_User + 128;
  21.   coDarkGray               = $808080;
  22.   DenyRepaint              = 0;
  23.   AllowRepaint             = 1;
  24.   BorderWidth              = 1;
  25.  
  26. type
  27.   PTool = ^TTool;
  28.   TTool = object(TObject)
  29.     Parent: PWindowsObject;
  30.     constructor Init(AParent: PWindowsObject);
  31.     function    GetWidth: Integer; virtual;
  32.     procedure   Check(State: Boolean); virtual;
  33.     function    GetHeight: Integer; virtual;
  34.     procedure   GetRect(var AR: TRect); virtual;
  35.     function    GetPart: Real; virtual;
  36.     procedure   Resize(APart: Real); virtual;
  37.     function    HitTest(P: TPoint): Boolean; virtual;
  38.     function    HitSize(P: TPoint): Boolean; virtual;
  39.     procedure   Paint(DC, AMemDC: HDC; var PS: TPaintStruct); virtual;
  40.     procedure   BeginCapture(P: TPoint); virtual;
  41.     procedure   ContinueCapture(P: TPoint); virtual;
  42.     function    EndCapture(SendTo: HWnd; P: TPoint): Boolean; virtual;
  43.     procedure   BeginNCapture(P: TPoint); virtual;
  44.     procedure   ContinueNCapture(P: TPoint); virtual;
  45.     function    EndNCapture(SendTo: HWnd; P: TPoint): Boolean; virtual;
  46.     procedure   BeginSCapture(P: TPoint); virtual;
  47.     procedure   ContinueSCapture(P: TPoint); virtual;
  48.     function    EndSCapture(SendTo: HWnd; P: TPoint): Boolean; virtual;
  49.     function    HasCommand(Command: Word): Boolean; virtual;
  50.     function    IsToolChecked: Boolean; virtual;
  51.     function    GetCommand: Word; virtual;
  52.     procedure   Enable(State: Boolean); virtual;
  53.     procedure   SetOrigin(X, Y: Integer); virtual;
  54.     procedure   CalculateWidth(BarWidth: Word; var XOfs: Integer); virtual;
  55.   end;
  56.  
  57.   PButtonBar = ^TButtonBar;
  58.   TButtonBar = object(TWindow)
  59.     ButtonsCount: Integer;
  60.     Buttons     : TCollection;
  61.     Capture     : PTool;
  62.     Sizing      : Boolean;
  63.     constructor Init(AParent: PWindowsObject; AnItemList: PItemsList; ABarColor: TColorRef);
  64.     destructor  Done; virtual;
  65.     function    CreateTool(Num: Integer; Origin: TPoint; Command: Word;
  66.                            BtnName: PChar; BtnPart: Real; AnAlign: Word; AColor: TColorRef): PTool;
  67.     procedure   EnableTool(Command: Word; NewState: Boolean); virtual;
  68.     procedure   CheckTool(Command: Word);
  69.     function    GetHeight: Integer;
  70.     function    GetClassName: PChar; virtual;
  71.     procedure   GetWindowClass(var WC: TWndClass); virtual;
  72.     procedure   GetToolPos(ToolID: Integer; var StartPos, EndPos: Integer); virtual;
  73.     function    GetToolPart(ToolID: Integer): Real;
  74.     function    GetSortOrder: Integer;
  75.     procedure   Paint(DC: HDC; var PS: TPaintStruct); virtual;
  76.     procedure   AMCalcParentClientRect(var Msg: TMessage); virtual wm_First + tm_CalcParentClientRect;
  77.     procedure   ToolSizingEnd(var Msg: TMessage); virtual wm_First + tm_SizingEnd;
  78.     procedure   WMLButtonDown(var Msg: TMessage); virtual wm_First + wm_LButtonDown;
  79.     procedure   WMMouseMove(var Msg: TMessage); virtual wm_First + wm_MouseMove;
  80.     procedure   WMLButtonUp(var Msg: TMessage); virtual wm_First + wm_LButtonUp;
  81.   end;
  82.  
  83.   PBarButton = ^TBarButton;
  84.   TBarButton = object(TTool)
  85.     Caption     : PChar;
  86.     Command     : Word;
  87.     Part        : Real;
  88.     Align       : Word;
  89.     NCapturing,
  90.     SCapturing,
  91.     IsPressed,
  92.     IsEnabled,
  93.     IsChecked   : Boolean;
  94.     R           : TRect;
  95.     GlyphSize   : TPoint;
  96.     CapDC,
  97.     MemDC       : HDC;
  98.     BarColor    : TColorRef;
  99.     constructor Init(AParent: PWindowsObject; ACommand: Word; AName: PChar; APart: Real; AnAlign: Word;
  100.                      AColor: TColorRef);
  101.     destructor  Done; virtual;
  102.     function    HasCommand(ACommand: Word): Boolean; virtual;
  103.     function    IsToolChecked: Boolean; virtual;
  104.     function    GetCommand: Word; virtual;
  105.     procedure   Enable(State: Boolean); virtual;
  106.     procedure   Check(State: Boolean); virtual;
  107.     function    GetWidth: Integer; virtual;
  108.     function    GetHeight: Integer; virtual;
  109.     procedure   GetRect(var AR: TRect); virtual;
  110.     function    GetPart: Real; virtual;
  111.     procedure   Resize(APart: Real); virtual;
  112.     procedure   SetOrigin(X, Y: Integer); virtual;
  113.     function    HitTest(P: TPoint): Boolean; virtual;
  114.     function    HitSize(P: TPoint): Boolean; virtual;
  115.     procedure   CalculateWidth(BarWidth: Word; var XOfs: Integer); virtual;
  116.     procedure   Paint(DC, AMemDC: HDC; var PS: TPaintStruct); virtual;
  117.     procedure   PaintState(DC, AMemDC: HDC);
  118.     procedure   BeginNCapture(P: TPoint); virtual;
  119.     procedure   ContinueNCapture(P: TPoint); virtual;
  120.     function    EndNCapture(SendTo: HWnd; P: TPoint): Boolean; virtual;
  121.     procedure   BeginSCapture(P: TPoint); virtual;
  122.     procedure   ContinueSCapture(P: TPoint); virtual;
  123.     function    EndSCapture(SendTo: HWnd; P: TPoint): Boolean; virtual;
  124.     procedure   PressIn;
  125.     procedure   PressOut;
  126.   end;
  127.  
  128. { Unit wide resources }
  129. var
  130.   ButtonFont  : HFont;
  131.   WhitePen,
  132.   DarkGrayPen,
  133.   BlackPen,
  134.   DotPen      : HPen;
  135.   GrayBrush,
  136.   GrayingBrush: HBrush;
  137.   SizCursor,
  138.   ArrowCursor : HCursor;
  139.  
  140. implementation
  141.  
  142. function Max(A, B: Integer): Integer;
  143. begin
  144.   if A > B then
  145.     Max := A
  146.   else
  147.     Max := B;
  148. end;
  149.  
  150. { ********** TTool *********** }
  151.  
  152. constructor TTool.Init(AParent: PWindowsObject);
  153. begin
  154.   Parent := AParent;
  155. end;
  156.  
  157. function TTool.GetWidth: Integer;
  158. begin
  159.   GetWidth := 0;
  160. end;
  161.  
  162. function TTool.GetHeight: Integer;
  163. begin
  164.   GetHeight := 0;
  165. end;
  166.  
  167. procedure TTool.GetRect(var AR: TRect);
  168. begin
  169. end;
  170.  
  171. function TTool.GetPart: Real;
  172. begin
  173. end;
  174.  
  175. procedure TTool.Resize;
  176. begin
  177. end;
  178.  
  179. function TTool.HitTest(P: TPoint): Boolean;
  180. begin
  181.   HitTest := False;
  182. end;
  183.  
  184. function TTool.HitSize(P: TPoint): Boolean;
  185. begin
  186.   HitSize := False;
  187. end;
  188.  
  189. procedure TTool.Paint(DC, AMemDC: HDC; var PS: TPaintStruct);
  190. begin
  191. end;
  192.  
  193. procedure TTool.BeginCapture(P: TPoint);
  194. begin
  195. end;
  196.  
  197. procedure TTool.ContinueCapture(P: TPoint);
  198. begin
  199. end;
  200.  
  201. function TTool.EndCapture(SendTo: HWnd; P: TPoint): Boolean;
  202. begin
  203. end;
  204.  
  205. procedure TTool.BeginNCapture(P: TPoint);
  206. begin
  207. end;
  208.  
  209. procedure TTool.ContinueNCapture(P: TPoint);
  210. begin
  211. end;
  212.  
  213. function TTool.EndNCapture(SendTo: HWnd; P: TPoint): Boolean;
  214. begin
  215. end;
  216.  
  217. procedure TTool.BeginSCapture(P: TPoint);
  218. begin
  219. end;
  220.  
  221. procedure TTool.ContinueSCapture(P: TPoint);
  222. begin
  223. end;
  224.  
  225. function TTool.EndSCapture(SendTo: HWnd; P: TPoint): Boolean;
  226. begin
  227. end;
  228.  
  229. procedure TTool.Check(State: Boolean);
  230. begin
  231. end;
  232.  
  233. procedure TTool.Enable(State: Boolean);
  234. begin
  235. end;
  236.  
  237. procedure TTool.SetOrigin(X, Y: Integer);
  238. begin
  239. end;
  240.  
  241. function TTool.HasCommand(Command: Word): Boolean;
  242. begin
  243.   HasCommand := False;
  244. end;
  245.  
  246. procedure TTool.CalculateWidth(BarWidth: Word; var Xofs: Integer);
  247. begin
  248. end;
  249.  
  250. function TTool.IsToolChecked: Boolean;
  251. begin
  252.   IsToolChecked := False;
  253. end;
  254.  
  255. function TTool.GetCommand: Word;
  256. begin
  257.   GetCommand := 0;
  258. end;
  259.  
  260. { ********** TButtonBar ********** }
  261.  
  262. constructor TButtonBar.Init(AParent: PWindowsObject; AnItemList: pItemsList; ABarColor: TColorRef);
  263. var
  264.   X: Integer;
  265.   Origin: TPoint;
  266.   P: PTool;
  267. begin
  268.   inherited Init(AParent, nil);
  269.   Attr.Style := ws_Child or ws_Visible or ws_Border;
  270.   SetFlags(wb_MDIChild, False);
  271.   DefaultProc := @DefWindowProc;
  272.   Attr.X := -1;
  273.   Attr.Y := -1;
  274.   Attr.W := 20;
  275.   Attr.H := 18;
  276.   Capture := nil;
  277.   Sizing := False;
  278.   ButtonsCount := AnItemList^.ColNumber;
  279.   Buttons.Init(ButtonsCount, 1);
  280.   Origin.X := 0;
  281.   Origin.Y := 0;
  282.   for X := 1 to ButtonsCount do
  283.     With AnItemList^.Items^[X] do
  284.     begin
  285.       P := CreateTool(X, Origin, ItemID, Caption, Part, Align, ABarColor);
  286.       if P <> nil then
  287.       begin
  288.         Inc(Origin.X, 20);
  289.         if AnItemList^.Items^[X].Sort = True then P^.Check(True);
  290.         Buttons.Insert(P);
  291.       end;
  292.     end;
  293. end;
  294.  
  295. destructor TButtonBar.Done;
  296. begin
  297.   inherited Done;
  298.   Buttons.Done;
  299. end;
  300.  
  301. function TButtonBar.CreateTool(Num: Integer; Origin: TPoint;
  302.                                Command: Word; BtnName: PChar;
  303.                                BtnPart: Real; AnAlign: Word; AColor: TColorRef): PTool;
  304. begin
  305.   CreateTool := New(PBarButton, Init(@Self, Command, BtnName, BtnPart, AnAlign, AColor));
  306. end;
  307.  
  308. procedure TButtonBar.EnableTool(Command: Word; NewState: Boolean);
  309. var
  310.   P: PTool;
  311.  
  312.   function FoundIt(P: PTool): Boolean; far;
  313.   begin
  314.     FoundIt := P^.HasCommand(Command);
  315.   end;
  316.  
  317. begin
  318.   P := Buttons.FirstThat(@FoundIt);
  319.   if P <> nil then
  320.     P^.Enable(NewState);
  321. end;
  322.  
  323. function TButtonBar.GetClassName: PChar;
  324. begin
  325.   GetClassName := 'MButtonBar';
  326. end;
  327.  
  328. procedure TButtonBar.GetWindowClass(var WC: TWndClass);
  329. begin
  330.   TWindow.GetWindowClass(WC);
  331.   WC.hbrBackground := GetStockObject(Null_Brush);
  332.   WC.hCursor := 0;
  333. end;
  334.  
  335. procedure TButtonBar.GetToolPos(ToolID: Integer; var StartPos, EndPos: Integer);
  336. var
  337.   P: PTool;
  338.   R: TRect;
  339.  
  340.   function FoundIt(P: PTool): Boolean; far;
  341.   begin
  342.     FoundIt := P^.HasCommand(ToolID);
  343.   end;
  344.  
  345. begin
  346.   P := Buttons.FirstThat(@FoundIt);
  347.   P^.GetRect(R);
  348.   StartPos := R.left;
  349.   EndPos := R.Right;
  350. end;
  351.  
  352. function TButtonBar.GetHeight: Integer;
  353. var
  354.   P: PTool;
  355. begin
  356.   GetHeight := Attr.H;
  357. end;
  358.  
  359. function TButtonBar.GetToolPart(ToolID: Integer): Real;
  360. var
  361.   P: PTool;
  362.  
  363.   function FoundIt(P: PTool): Boolean; far;
  364.   begin
  365.     FoundIt := P^.HasCommand(ToolID);
  366.   end;
  367.  
  368. begin
  369.   P := Buttons.FirstThat(@FoundIt);
  370.   GetToolPart := P^.GetPart;
  371. end;
  372.  
  373. function TButtonBar.GetSortOrder: Integer;
  374. var
  375.   P: PTool;
  376.  
  377.   function FoundIt(P: PTool): Boolean; far;
  378.   begin
  379.     FoundIt := P^.IsToolChecked;
  380.   end;
  381.  
  382. begin
  383.   P := Buttons.FirstThat(@FoundIt);
  384.   GetSortOrder := P^.GetCommand;
  385. end;
  386.  
  387. procedure TButtonBar.Paint(DC: HDC; var PS: TPaintStruct);
  388. var
  389.   MemDC: HDC;
  390.  
  391.   procedure PaintIt(Item: PTool); far;
  392.   begin
  393.     Item^.Paint(DC, MemDC, PS);
  394.   end;
  395.  
  396. begin
  397.   MemDC := CreateCompatibleDC(DC);
  398.   Buttons.ForEach(@PaintIt);
  399.   DeleteDC(MemDC);
  400. end;
  401.  
  402. procedure TButtonBar.AMCalcParentClientRect(var Msg: TMessage);
  403. var
  404.   BB,                                { ButtonBar rect in screen coords }
  405.   PC,                                { Parent client rect in screen coords }
  406.   NewBB,                             { New ButtonBar rect in screen coords }
  407.   R: TRect;                          { Scratch }
  408.   S2PC, S2BB: TPoint;                { Screen to local coord conversion offsets }
  409.   XOfs: Integer;
  410.  
  411.   procedure SetWidth(Item: PTool); far;
  412.   begin
  413.     Item^.CalculateWidth(PC.Right - PC.Left, XOfs);
  414.   end;
  415.  
  416. begin
  417.   PC := PRect(Msg.LParam)^;
  418.   R := PC;
  419.   ClientToScreen(Parent^.HWindow, PPoint(@PC)^);
  420.   ClientToScreen(Parent^.HWindow, PPoint(@PC.Right)^);
  421.   S2PC.X := PC.Left - R.Left;
  422.   S2PC.Y := PC.Top - R.Top;
  423.  
  424.   GetWindowRect(HWindow, BB);
  425.   S2BB.X := BB.Left;
  426.   S2BB.Y := BB.Top;
  427.  
  428.   if Bool(Msg.WParam) then           { We have permission to repaint & reposition }
  429.   begin
  430.     if BB.Right <> PC.Right then     { Parent client relative coords }
  431.       SetWindowPos(HWindow, 0, -1, 0, PC.Right - S2BB.X, BB.Bottom - S2BB.Y, swp_NoZOrder);
  432.     if BB.Right < PC.Right then      { Width increases, paint new area }
  433.     begin
  434.       SetRect(R, BB.Right - S2BB.X - 2, BB.Top - S2BB.Y - 1, PC.Right - S2BB.X + 1, BB.Bottom - S2BB.Y + 1);
  435.       InvalidateRect(HWindow, @R, True);
  436.     end;
  437.     if PC.Top < BB.Bottom then
  438.       PC.Top := BB.Bottom;
  439.   end;
  440.  
  441.   { Map the screen coordinates PC record back into parent relative coords }
  442.   SetRect(PRect(Msg.LParam)^, PC.Left - S2PC.X, PC.Top - S2PC.Y, PC.Right - S2PC.X, PC.Bottom - S2PC.Y);
  443.  
  444.   XOfs := 0;
  445.   Buttons.ForEach(@SetWidth);
  446. end;
  447.  
  448. procedure TButtonBar.ToolSizingEnd(var Msg: TMessage);
  449. var
  450.   R, PR, SR: TRect;
  451.   P: TPoint;
  452.   PBtn, SBtn: PTool;
  453.   Index: Integer;
  454.   TWidth, PWidth, SWidth, BWidth: Integer;
  455.   PPart, SPart, Total: Real;
  456.   XOfs: Integer;
  457.  
  458.   function FoundIt(Item: PTool): Boolean; far;
  459.   begin
  460.     FoundIt := Item^.HasCommand(Msg.wParam);
  461.   end;
  462.  
  463.   procedure AllPart(Item: PTool); far;
  464.   begin
  465.     Total := Total + Item^.GetPart;
  466.   end;
  467.  
  468.   procedure SetWidth(Item: PTool); far;
  469.   begin
  470.     Item^.CalculateWidth(BWidth, XOfs);
  471.   end;
  472.  
  473. begin
  474.   GetClientRect(HWindow, R);
  475.   BWidth := R.Right - R.Left + 1;
  476.   P := TPoint(Msg.LParam);
  477.   PBtn := Buttons.FirstThat(@FoundIt);
  478.   Index := Buttons.Indexof(PBtn);
  479.   SBtn := Buttons.At(Succ(Index));
  480.   PBtn^.GetRect(PR);
  481.   if (P.X - PR.Left) < 10 then
  482.     P.X := PR.Left + 10;
  483.   SBtn^.GetRect(SR);
  484.   if (SR.Right - P.X) < 10 then
  485.     P.X := SR.Right - 10;
  486.   TWidth := PBtn^.GetWidth + SBtn^.GetWidth;
  487.   PWidth := P.X - PR.Left;
  488.   if (PWidth <> 0) then
  489.     PPart := PWidth / BWidth
  490.   else
  491.     PPart := 0;
  492.   SWidth := TWidth - PWidth;
  493.   if (SWidth <> 0) then
  494.     SPart := SWidth / BWidth
  495.   else
  496.     SPart := 0;
  497.   PBtn^.Resize(PPart);
  498.   SBtn^.Resize(SPart);
  499.   Total := 0;
  500.   Buttons.ForEach(@AllPart);
  501.   SPart := SPart - (Total - 1);
  502.   SBtn^.Resize(SPart);
  503.   XOfs := 0;
  504.   Buttons.ForEach(@SetWidth);
  505.   SendMessage(Parent^.HWindow, tm_SizingEnd, 0, 0);
  506. end;
  507.  
  508. procedure TButtonBar.CheckTool(Command: Word);
  509. var
  510.   P: PTool;
  511.  
  512.   function FoundIt(P: PTool): Boolean; far;
  513.   begin
  514.     FoundIt := P^.HasCommand(Command);
  515.   end;
  516.  
  517.   procedure UnCheck(Item: PTool); far;
  518.   begin
  519.     Item^.Check(False);
  520.   end;
  521.  
  522. begin
  523.   P := nil;
  524.   P := Buttons.FirstThat(@FoundIt);
  525.   if P <> nil then
  526.   begin
  527.     Buttons.ForEach(@UnCheck);
  528.     P^.Check(True);
  529.   end;
  530. end;
  531.  
  532. { ********** Mouse operation processes ********** }
  533.  
  534. procedure TButtonBar.WMLButtonDown(var Msg: TMessage);
  535. var
  536.   NCapture, SCapture: PTool;
  537.  
  538.   function IsHit(Item: PTool): Boolean; far;
  539.   begin
  540.     IsHit := Item^.HitTest(TPoint(Msg.LParam));
  541.   end;
  542.  
  543.   function IsSizeHit(Item: PTool): Boolean; far;
  544.   begin
  545.     IsSizeHit := Item^.HitSize(TPoint(Msg.LParam));
  546.   end;
  547.  
  548. begin
  549.   NCapture := Buttons.FirstThat(@IsHit);
  550.   SCapture := Buttons.FirstThat(@IsSizeHit);
  551.   if (SCapture <> nil) and (Buttons.IndexOf(SCapture) <> Pred(ButtonsCount)) then
  552.   begin
  553.     Sizing := True;
  554.     Capture := SCapture;
  555.     Capture^.BeginSCapture(TPoint(Msg.LParam));
  556.   end
  557.   else
  558.     if NCapture <> nil then
  559.     begin
  560.       Capture := NCapture;
  561.       Capture^.BeginNCapture(TPoint(Msg.LParam));
  562.     end;
  563. end;
  564.  
  565. procedure TButtonBar.WMMouseMove(var Msg: TMessage);
  566. var
  567.   SB: PTool;
  568.  
  569.   function IsSizeHit(Item: PTool): Boolean; far;
  570.   begin
  571.     IsSizeHit := Item^.HitSize(TPoint(Msg.LParam));
  572.   end;
  573.  
  574. begin
  575.   if (Capture <> nil) then
  576.     if Sizing then
  577.       Capture^.ContinueSCapture(TPoint(Msg.LParam))
  578.     else
  579.       Capture^.ContinueNCapture(TPoint(Msg.LParam))
  580.   else
  581.   begin
  582.     SB := Buttons.FirstThat(@IsSizeHit);
  583.     if SB <> nil then
  584.       begin
  585.         if Buttons.IndexOf(SB) <> Pred(ButtonsCount) then
  586.           SetCursor(SizCursor);
  587.       end
  588.     else
  589.       SetCursor(ArrowCursor);
  590.   end;
  591. end;
  592.  
  593. procedure TButtonBar.WMLButtonUp(var Msg: TMessage);
  594.  
  595.   procedure UnCheck(Item: PTool); far;
  596.   begin
  597.     Item^.Check(False);
  598.   end;
  599.  
  600. begin
  601.   if (Capture <> nil) then
  602.   begin
  603.     if Sizing then
  604.     begin
  605.        if Capture^.EndSCapture(HWindow, TPoint(Msg.LParam)) then
  606.        begin
  607.          Sizing := False;
  608.          Capture := nil;
  609.        end;
  610.     end
  611.   else
  612.     begin
  613.        if Capture^.EndNCapture(Parent^.HWindow, TPoint(Msg.LParam)) then
  614.        begin
  615.          if Capture^.HitTest(TPoint(Msg.LParam)) then
  616.          begin
  617.            Buttons.ForEach(@UnCheck);
  618.            Capture^.Check(True);
  619.          end;
  620.          Capture := nil;
  621.        end;
  622.     end;
  623.   end;
  624. end;
  625.  
  626. { ********** TBarButton ********** }
  627.  
  628. constructor TBarButton.Init(AParent: PWindowsObject; ACommand: Word;
  629.                             AName: PChar; APart: Real; AnAlign: Word; AColor: TColorRef);
  630. begin
  631.   inherited Init(AParent);
  632.   CapDC := 0;
  633.   BarColor := AColor;
  634.   MemDC := 0;
  635.   IsPressed := False;
  636.   NCapturing := False;
  637.   SCapturing := False;
  638.   IsEnabled := True;
  639.   IsChecked := False;
  640.   Command := ACommand;
  641.   Align := AnAlign;
  642.   GetMem(Caption, StrLen(AName) + 1);
  643.   StrCopy(Caption, AName);
  644.   Part := APart;
  645.   GlyphSize.Y := 19;
  646. end;
  647.  
  648. destructor TBarButton.Done;
  649. begin
  650.   if NCapturing then
  651.   begin
  652.     DeleteDC(MemDC);
  653.     ReleaseDC(Parent^.HWindow, CapDC);
  654.     ReleaseCapture;
  655.   end;
  656.   if SCapturing then
  657.   begin
  658.     ReleaseCapture;
  659.   end;
  660.   FreeMem(Caption, StrLen(Caption) + 1);
  661.   inherited Done;
  662. end;
  663.  
  664. function TBarButton.HasCommand(ACommand: Word): Boolean;
  665. begin
  666.   HasCommand := (Command = ACommand);
  667. end;
  668.  
  669. procedure TBarButton.Enable(State: Boolean);
  670. begin
  671.   if (IsEnabled <> State) and (Parent^.HWindow <> 0) then
  672.     InvalidateRect(Parent^.HWindow, @R, False);
  673.   IsEnabled := State;
  674. end;
  675.  
  676. procedure TBarButton.Check(State: Boolean);
  677. begin
  678.   if (not State) and IsPressed then Exit;
  679.   if (IsChecked <> State) and (Parent^.Hwindow <> 0) then
  680.     InvalidateRect(Parent^.HWindow, @R, False);
  681.   IsChecked := State;
  682.   IsPressed := False;
  683. end;
  684.  
  685. function TBarButton.GetWidth: Integer;
  686. begin
  687.   GetWidth := R.Right - R.Left;
  688. end;
  689.  
  690. function TBarButton.GetHeight: Integer;
  691. begin
  692.   GetHeight := R.Bottom - R.Top;
  693. end;
  694.  
  695. procedure TBarButton.GetRect(var AR: TRect);
  696. begin
  697.   Move(R, AR, SizeOf(TRect));
  698. end;
  699.  
  700. function TBarButton.GetPart: Real;
  701. begin
  702.   GetPart := Part;
  703. end;
  704.  
  705. procedure TBarButton.Resize(APart: Real);
  706. begin
  707.   Part := APart;
  708. end;
  709.  
  710. procedure TBarButton.SetOrigin(X, Y: Integer);
  711. begin
  712.   SetRect(R, X, Y, X + GlyphSize.X, Y + GlyphSize.Y);
  713. end;
  714.  
  715. function TBarButton.HitTest(P: TPoint): Boolean;
  716. begin
  717.   HitTest := Boolean(PtInRect(R, P));
  718. end;
  719.  
  720. function TBarButton.HitSize(P: TPoint): Boolean;
  721. var
  722.   InActive: TRect;
  723. begin
  724.   Move(R, InActive, SizeOf(TRect));
  725.   InflateRect(InActive, -2, 0);
  726.   OffsetRect(InActive, -4, 0);
  727.   HitSize := not Boolean(PtInRect(InActive, P)) and Boolean(PtInRect(R, P));
  728. end;
  729.  
  730. procedure TBarButton.Paint(DC, AMemDC: HDC; var PS: TPaintStruct);
  731. begin
  732.   PaintState(DC, AMemDC);
  733. end;
  734.  
  735. procedure TBarButton.PaintState(DC, AMemDC: HDC);
  736. const
  737.   RectDelta = 3;
  738. var
  739.   OldBrush: HBrush;
  740.   OldPen: HPen;
  741.   OldFont: HFont;
  742.   Offset, OffsetX: Integer;
  743.   TextR: TRect;
  744. begin
  745.   OldPen := SelectObject(DC, BlackPen);
  746.   OldBrush := SelectObject(DC, GrayBrush);
  747.   OldFont := SelectObject(DC, ButtonFont);
  748.   With R do
  749.   begin
  750.     FillRect(DC, R, GrayBrush);
  751.     Rectangle(DC, Left, Top - 1, Right + 1, Bottom + 1);
  752.     if (not IsPressed) and (not IsChecked) then
  753.     begin
  754.       Offset := BorderWidth;
  755.       SelectObject(DC, WhitePen);
  756.       MoveTo(DC, Left + 1, Bottom - 1);
  757.       LineTo(DC, Left + 1, Top);
  758.       LineTo(DC, Right - 2, Top);
  759.       SelectObject(DC, DarkGrayPen);
  760.       MoveTo(DC, Right - 1, Top);
  761.       LineTo(DC, Right - 1, Bottom - 2);
  762.       LineTo(DC, Left + 1, Bottom - 2);
  763.     end
  764.     else
  765.     begin
  766.       Offset := BorderWidth + 1;
  767.       SelectObject(DC, DarkGrayPen);
  768.       MoveTo(DC, Left + 1, Bottom - 1);
  769.       LineTo(DC, Left + 1, Top);
  770.       LineTo(DC, Right, Top);
  771.     end;
  772.   end;
  773.  
  774.   SetBkMode(DC, Transparent);
  775.   if IsEnabled then
  776.     SetTextColor(DC, BarColor)
  777.   else
  778.     SetTextColor(DC, coDarkGray);
  779.  
  780.   Move(R, TextR, SizeOf(TRect));
  781.   Inc(TextR.Left, RectDelta);
  782.   Dec(TextR.Right, RectDelta);
  783.   Inc(TextR.Top, Offset);
  784.   case Align of
  785.     DT_LEFT, DT_CENTER: Inc(TextR.Left, Offset + 2);
  786.     DT_RIGHT: Dec(TextR.Right, (Offset*-1) + 3);
  787.   end;
  788.   DrawText(DC, Caption, StrLen(Caption), TextR, Align or DT_TOP);
  789.   SelectObject(DC, OldBrush);
  790.   SelectObject(DC, OldPen);
  791.   SelectObject(DC, OldFont);
  792. end;
  793.  
  794. procedure TBarButton.PressIn;
  795. begin
  796.   if (not IsPressed) and IsEnabled and (not IsChecked) then
  797.   begin
  798.     IsPressed := True;
  799.     PaintState(CapDC, MemDC);
  800.   end;
  801. end;
  802.  
  803. procedure TBarButton.PressOut;
  804. begin
  805.   if IsPressed and (not IsChecked) then
  806.   begin
  807.     IsPressed := False;
  808.     PaintState(CapDC, MemDC);
  809.   end;
  810. end;
  811.  
  812. procedure TBarButton.BeginNCapture(P: TPoint);
  813. begin
  814.   CapDC := GetDC(Parent^.HWindow);
  815.   MemDC := CreateCompatibleDC(CapDC);
  816.   IsPressed := False;
  817.   NCapturing := True;
  818.   SetCapture(Parent^.HWindow);
  819.   if HitTest(P) then
  820.     PressIn;
  821. end;
  822.  
  823. procedure TBarButton.BeginSCapture(P: TPoint);
  824. begin
  825.   IsPressed := False;
  826.   SCapturing := True;
  827.   SendMessage(Parent^.Parent^.HWindow, tm_FirstColSize, 0, Longint(P));
  828.   SetCapture(Parent^.HWindow);
  829. end;
  830.  
  831. procedure TBarButton.ContinueNCapture(P: TPoint);
  832. begin
  833.   if HitTest(P) then
  834.     PressIn
  835.   else
  836.     PressOut;
  837. end;
  838.  
  839. procedure TBarButton.ContinueSCapture(P: TPoint);
  840. begin
  841.   { Draw Dotted line in CapDC }
  842.   SendMessage(Parent^.Parent^.HWindow, tm_NewColSize, 0, Longint(P));
  843. end;
  844.  
  845. { The boolean function result of EndCapture indicates whether the tool button
  846.   has released the mouse capture or not.  The Toolbar should not clear its
  847.   capture field/state until the toolbutton says to.
  848.  
  849.   The SendTo parameter is the HWindow to notify that the tool button was clicked
  850.   upon, if such is the case.  This code emulates a menu command message, but
  851.   any message type could be used. }
  852.  
  853. function TBarButton.EndNCapture(SendTo: HWnd; P: TPoint): Boolean;
  854. begin
  855.   if HitTest(P) then
  856.     if not IsChecked then PostMessage(SendTo, wm_Command, Command, 0);
  857.   EndNCapture := True;
  858.   ReleaseCapture;
  859.   NCapturing := False;
  860.   DeleteDC(MemDC);
  861.   ReleaseDC(Parent^.HWindow, CapDC);
  862.   MemDC := 0;
  863.   CapDC := 0;
  864. end;
  865.  
  866. function TBarButton.EndSCapture(SendTo: HWnd; P: TPoint): Boolean;
  867. begin
  868.   PostMessage(SendTo, tm_SizingEnd, Command, LongInt(P));
  869.   EndSCapture := True;
  870.   ReleaseCapture;
  871.   NCapturing := False;
  872.   MemDC := 0;
  873.   CapDC := 0;
  874. end;
  875.  
  876. procedure TBarButton.CalculateWidth(BarWidth: Word; var XOfs: Integer);
  877. begin
  878.   GlyphSize.X := Round((BarWidth*Part) + 1);
  879.   if (BarWidth - (XOfs + GlyphSize.X)) < 0 then
  880.     GlyphSize.X := BarWidth - XOfs - 1;
  881.   SetRect(R, XOfs, 0, XOfs + GlyphSize.X, GlyphSize.Y);
  882.   Inc(XOfs, GlyphSize.X);
  883. end;
  884.  
  885. function TBarButton.IsToolChecked: Boolean;
  886. begin
  887.   IsToolChecked := IsChecked;
  888. end;
  889.  
  890. function TBarButton.GetCommand: Word;
  891. begin
  892.   GetCommand := Command;
  893. end;
  894.  
  895. { Allocate unit wide resources }
  896.  
  897. procedure AllocateResources;
  898. var
  899.   LBrush: TLogBrush;
  900.   lButtonFont: TLogFont;
  901.  
  902. begin
  903.   { Allocate graying brush (used to disable buttons) }
  904.   LBrush.lbStyle := bs_Pattern;
  905.   Word(LBrush.lbHatch) := LoadBitMap(HInstance, 'GrayingBitmap');
  906.   GrayingBrush := CreateBrushIndirect(LBrush);
  907.   DeleteObject(Word(LBrush.lbHatch));
  908.  
  909.   { Allocate font for buttons captions }
  910.   with lButtonFont do
  911.   begin
  912.     lfHeight        := 10;
  913.     lfWidth         := 0;
  914.     lfEscapement    := 0;
  915.     lfOrientation   := 0;
  916.     lfWeight        := fw_Regular;
  917.     lfItalic        := 0;
  918.     lfUnderline     := 0;
  919.     lfStrikeOut     := 0;
  920.     lfCharSet       := Default_CharSet;
  921.     lfOutPrecision  := Out_Default_Precis;
  922.     lfClipPrecision := Clip_Default_Precis;
  923.     lfQuality       := Proof_Quality;
  924.     lfPitchAndFamily:= Variable_Pitch or FF_Swiss;
  925.     StrCopy(lfFaceName, 'MS Sans Serif');
  926.   end;
  927.   ButtonFont := CreateFontIndirect(lButtonFont);
  928.  
  929.   { Allocate drawing pens and brushes }
  930.   GrayBrush := GetStockObject(LtGray_Brush);
  931.   WhitePen := GetStockObject(White_Pen);
  932.   BlackPen := GetStockObject(Black_Pen);
  933.   DarkGrayPen := CreatePen(ps_Solid, 1, coDarkGray);
  934.   DotPen := CreatePen(ps_Dot, 1, 0);
  935.  
  936.   { Allocate column size cursor }
  937.   SizCursor := LoadCursor(HInstance, 'COLSIZE');
  938.   ArrowCursor := LoadCursor(0, IDC_ARROW);
  939. end;
  940.  
  941. { Free allocated resources }
  942.  
  943. procedure DeallocateResources;
  944. begin
  945.   DeleteObject(GrayingBrush);
  946.   DeleteObject(ButtonFont);
  947.   DeleteObject(DarkGrayPen);
  948.   DeleteObject(DotPen);
  949.   DestroyCursor(SizCursor);
  950. end;
  951.  
  952. var
  953.   SaveExit: Pointer;
  954.  
  955. procedure ExitBtnBar; far;
  956. begin
  957.   DeallocateResources;
  958.   ExitProc := SaveExit;
  959. end;
  960.  
  961. begin
  962.   SaveExit := ExitProc;
  963.   ExitProc := @ExitBtnBar;
  964.   AllocateResources;
  965. end.
  966.